Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue72/alfresco/AAHuffmn.pas

Pascal/Delphi Source File | 2001-07-05 | 30.9 KB | 1,010 lines

{*********************************************************}
{* AAHuffmn                                              *}
{* Copyright (c) Julian M Bucknall 1999, 2000            *}
{* All rights reserved.                                  *}
{*********************************************************}
{* Huffman compression and decompression                 *}
{*********************************************************}

{Note: this unit is released as freeware. In other words, you are free
       to use this unit in your own applications, however I retain all
       copyright to the code. JMB}

unit AAHuffmn;

{Version 1: initial release}
{Version 2: New method for writing/reading the Huffman tree}

interface

uses
  SysUtils, Classes;

{$IFOPT D+}
{$DEFINE InDebugMode}
{$ENDIF}

procedure HuffmanCompress(aInStream, aOutStream : TStream);
procedure HuffmanDecompress(aInStream, aOutStream : TStream);

procedure HuffmanCompressBlock(var aBuffer;
                                   aSize      : integer;
                                   aOutStream : TStream);
procedure HuffmanDecompressBlock(aInStream : TStream;
                             var aBuffer;
                                 aSize     : integer);

implementation

const
  vaByte    = 0;   {value is a byte: 0..255}
  vaWord    = 1;   {value is a word: 255..65535}
  vaLongint = 2;   {value is a longint: all other values}

const
  Bit : array [0..7] of byte =  {bit masks}
        ($01, $02, $04, $08, $10, $20, $40, $80);

type
  PHuffmanNode = ^THuffmanNode;
  THuffmanNode = packed record
    hnCount    : longint;
    hnLeftInx  : longint;
    hnRightInx : longint;
  end;

  PHuffmanTree = ^THuffmanTree;
  THuffmanTree = array [0..510] of THuffmanNode;

type
  THuffmanCodeStr = string[255];

  PHuffmanCode = ^THuffmanCode;
  THuffmanCode = packed record
    hcBitCount : longint;
    hcCode     : array [0..31] of byte;
  end;

  PHuffmanCodes = ^THuffmanCodes;
  THuffmanCodes = array [0..255] of THuffmanCode;


{===THuffmanPriorityQueue=============================================}
type
  longint = integer;

  THuffmanPriorityQueue = class
    {-A priority queue for Huffman compression}
    private
      pqList : TList;
      pqTree : PHuffmanTree;
    protected
      function pqGetCount : integer;

      procedure pqBubbleUp(aFromInx : integer; aItem : longint);
      procedure pqTrickleDown(aFromInx : integer; aItem : longint);
    public
      constructor Create(aHTree : PHuffmanTree);
        {-Create the priority queue}
      destructor Destroy; override;
        {-Dispose of the priority queue}

      procedure Add(aItem : longint);
        {-Add an item (ie, Huffman tree index) to the priority queue}
      function Remove : longint;
        {-Remove and return the item (ie, Huffman tree index) with the
          smallest count}

      property Count : integer read pqGetCount;
        {-Count of items in the queue}

      property List : TList read pqList;
  end;
{--------}
constructor THuffmanPriorityQueue.Create(aHTree : PHuffmanTree);
begin
  inherited Create;
  {create the queue's array; we know it'll be at most 256 elements}
  pqList := TList.Create;
  pqList.Capacity := 256;
  {remember the Huffman tree we're using}
  pqTree := aHTree;
end;
{--------}
destructor THuffmanPriorityQueue.Destroy;
begin
  pqList.Free;
  inherited Destroy;
end;
{--------}
procedure THuffmanPriorityQueue.Add(aItem : longint);
begin
  {add extra space at the end of the queue}
  pqList.Count := pqList.Count + 1;
  {now bubble the item up as far as it will go}
  pqBubbleUp(pred(pqList.Count), aItem);
end;
{--------}
procedure THuffmanPriorityQueue.pqBubbleUp(aFromInx : integer;
                                           aItem    : longint);
var
  ParentInx : integer;
  ItemCount : longint;
begin
  {while the item under consideration is smaller than its parent, swap
   it with its parent and continue from its new position}
  {Note: the parent for the child at index N is at (N-1) div 2}
  ItemCount := pqTree^[aItem].hnCount;
  ParentInx := (aFromInx - 1) div 2;
  {while our item has a parent, and it's greater than the parent...}
  while (aFromInx > 0) and
        (ItemCount <
           pqTree^[longint(pqList[ParentInx])].hnCount) do begin
    {move our parent down the tree}
    pqList[aFromInx] := pqList[ParentInx];
    aFromInx := ParentInx;
    ParentInx := (aFromInx - 1) div 2;
  end;
  {store our item in the correct place}
  pqList[aFromInx] := pointer(aItem);
end;
{--------}
function THuffmanPriorityQueue.pqGetCount : integer;
begin
  Result := pqList.Count;
end;
{--------}
procedure THuffmanPriorityQueue.pqTrickleDown(aFromInx : integer;
                                              aItem    : longint);
var
  ChildInx  : integer;
  ListCount : integer;
  ItemCount : longint;
begin
  {while the item under consideration is greater than one of its
   children, swap it with the smaller child and continue from its new
   position}
  {Note: the children for the parent at index N are at (2N+1) and
         2N+2}
  ItemCount := pqTree^[aItem].hnCount;
  ListCount := pqList.Count;
  {calculate the left child index}
  ChildInx := succ(aFromInx * 2);
  {while there is at least a left child...}
  while (ChildInx < ListCount) do begin
    {if there is a right child, calculate the index of the smaller
     child}
    if (succ(ChildInx) < ListCount) and
       (pqTree^[longint(pqList[ChildInx])].hnCount >
          pqTree^[longint(pqList[succ(ChildInx)])].hnCount) then
      inc(ChildInx);
    {if our item is less or equal to the smaller child, we're done}
    if (ItemCount <= pqTree^[longint(pqList[ChildInx])].hnCount) then
      Break;
    {otherwise move the smaller child up the tree, and move our item
     down the tree and repeat}
    pqList[aFromInx] := pqList[ChildInx];
    aFromInx := ChildInx;
    ChildInx := succ(aFromInx * 2);
  end;
  {store our item in the correct place}
  pqList[aFromInx] := pointer(aItem);
end;
{--------}
function THuffmanPriorityQueue.Remove : longint;
begin
  {return the item at the root}
  Result := longint(pqList[0]);
  {replace the root with the child at the lowest, rightmost position,
   and shrink the list}
  pqList[0] := pqList.Last;
  pqList.Count := pqList.Count - 1;
  {now trickle down the root item as far as it will go}
  if (pqList.Count > 0) then
    pqTrickleDown(0, longint(pqList[0]));
end;
{====================================================================}


{===bit streams======================================================}
const
  StreamBufferSize = 4096;
type
  TInputBitStream = class
    private
      FAccum      : byte;
      FBufEnd     : integer;
      FBuffer     : PAnsiChar;
      FBufPos     : integer;
      FMask       : byte;
      FStream     : TStream;
    protected
      procedure ibsReadBuffer;
    public
      constructor Create(aStream : TStream);
      destructor Destroy; override;

      function ReadBit : boolean;
      function ReadByte : byte;
  end;
  TOutputBitStream = class
    private
      FAccum      : byte;
      FBuffer     : PAnsiChar;
      FBufPos     : integer;
      FMask       : byte;
      FStream     : TStream;
      FStrmBroken : boolean;
    protected
      procedure obsWriteBuffer;
    public
      constructor Create(aStream : TStream);
      destructor Destroy; override;

      procedure WriteBit(aBit : boolean);
      procedure WriteByte(aByte : byte);
  end;
{--------}
constructor TInputBitStream.Create(aStream : TStream);
begin
  inherited Create;
  FStream := aStream;
  GetMem(FBuffer, StreamBufferSize);
end;
{--------}
destructor TInputBitStream.Destroy;
begin
  if (FBuffer <> nil) then begin
    FStream.Seek(-FBufEnd + FBufPos, soFromCurrent);
    FreeMem(FBuffer, StreamBufferSize);
  end;

  inherited Destroy;
end;
{--------}
procedure TInputBitStream.ibsReadBuffer;
begin
  FBufEnd := FStream.Read(FBuffer^, StreamBufferSize);
  if (FBufEnd = 0) then
    raise Exception.Create('No more data in input stream');
  FBufPos := 0;
end;
{--------}
function TInputBitStream.ReadBit : boolean;
begin
  {if we have no bits left in the current accumulator, read another
   accumulator byte and reset the mask}
  if (FMask = 0) then begin
    if (FBufPos >= FBufEnd) then
      ibsReadBuffer;
    FAccum := byte(FBuffer[FBufPos]);
    inc(FBufPos);
    FMask := 1;
  end;
  {take the next bit}
  Result := (FAccum and FMask) <> 0;
  FMask := FMask shl 1;          {overflow required on this statement}
end;
{--------}
function TInputBitStream.ReadByte : byte;
var
  Mask   : byte;
  Accum  : byte;
  ByteMask : byte;
begin
  {to speed up this process, we shall take copies of the object's
   fields; at the end we'll copy them back}
  Mask := FMask;
  Accum := FAccum;
  {prepare for the loop(s)}
  ByteMask := 1;
  Result := 0;
  {extract as many bits from the accumulator as we can, refilling as
   necessary}
  while (ByteMask <> 0) do begin
    {if the accumulator is empty, refill it and reset the mask}
    if (Mask = 0) then begin
      if (FBufPos >= FBufEnd) then
        ibsReadBuffer;
      Accum := byte(FBuffer[FBufPos]);
      inc(FBufPos);
      Mask := 1;
    end;
    {get the next bit}
    if ((Accum and Mask) <> 0) then
      Result := Result or ByteMask;
    Mask := Mask shl 1;          {overflow required on this statement}
    ByteMask := ByteMask shl 1;  {overflow required on this statement}
  end;
  {save the new values of the accumulator and the mask}
  FMask := Mask;
  FAccum := Accum;
end;
{--------}
constructor TOutputBitStream.Create(aStream : TStream);
begin
  inherited Create;
  FStream := aStream;
  GetMem(FBuffer, StreamBufferSize);
  FMask := 1; {ready for the first bit to be written}
end;
{--------}
destructor TOutputBitStream.Destroy;
begin
  if (FBuffer <> nil) then begin
    {if Mask is not equal to 1, it means that there are some bits in
     the accumulator that need to be written to the buffer; make sure
     the buffer is written to the underlying stream}
    if not FStrmBroken then begin
      if (FMask <> 1) then begin
        byte(FBuffer[FBufPos]) := FAccum;
        inc(FBufPos);
      end;
      if (FBufPos > 0) then
        obsWriteBuffer;
    end;
    FreeMem(FBuffer, StreamBufferSize);
  end;
  inherited Destroy;
end;
{--------}
procedure TOutputBitStream.obsWriteBuffer;
var
  BytesWrit : longint;
begin
  BytesWrit := FStream.Write(FBuffer^, FBufPos);
  if (BytesWrit <> FBufPos) then begin
    {we had a problem writing the buffer to the stream; raiuse an
     exception to say so, but first make sure so that we don't trigger
     the same exception in the Destroy as well}
    FStrmBroken := true;
    raise Exception.Create('Failed to write buffer to output stream');
  end;
  FBufPos := 0;
end;
{--------}
procedure TOutputBitStream.WriteBit(aBit : boolean);
begin
  {set the next spare bit}
  if aBit then
    FAccum := (FAccum or FMask);
  FMask := FMask shl 1;           {require overflow on this statement}
  {if we have no spare bits left in the current accumulator, write it
   to the buffer, and reset the accumulator and the mask}
  if (FMask = 0) then begin
    byte(FBuffer[FBufPos]) := FAccum;
    inc(FBufPos);
    if (FBufPos >= StreamBufferSize) then
      obsWriteBuffer;
    FAccum := 0;
    FMask := 1;
  end;
end;
{--------}
procedure TOutputBitStream.WriteByte(aByte : byte);
var
  Mask   : byte;
  Accum  : byte;
  ByteMask : byte;
begin
  {to speed up this process, we shall take copies of the object's
   fields; at the end we'll copy them back}
  Mask := FMask;
  Accum := FAccum;
  {prepare for the loop}
  ByteMask := 1;
  {store as many bits to the accumulator as we can, writing it out and
   clearing it as necessary}
  while (ByteMask <> 0) do begin
    {store the next bit}
    if ((aByte and ByteMask) <> 0) then
      Accum := Accum or Mask;
    Mask := Mask shl 1;          {overflow required on this statement}
    ByteMask := ByteMask shl 1;  {overflow required on this statement}
    {if needed, write out the accumulator & reset}
    if (Mask = 0) then begin
      byte(FBuffer[FBufPos]) := Accum;
      inc(FBufPos);
      if (FBufPos >= StreamBufferSize) then
        obsWriteBuffer;
      Accum := 0;
      Mask := 1;
    end;
  end;
  {save the new values of the accumulator and the mask}
  FMask := Mask;
  FAccum := Accum;
end;
{====================================================================}


{===Exception handling===============================================}
procedure RaiseWriteError;
begin
  raise Exception.Create('Cannot write to Huffman compressed stream');
end;
{--------}
procedure RaiseReadError;
begin
  raise Exception.Create('Expecting more data in Huffman compressed stream, but none left');
end;
{--------}
procedure RaiseReadCorruptError;
begin
  raise Exception.Create('Huffman compressed stream contains corrupted data');
end;
{====================================================================}


{===Helper routines==================================================}
procedure WriteBits(const aHCode  : THuffmanCode;
                          aStream : TOutputBitStream);
var
  ByteNum : integer;
  BitNum  : integer;
  i       : integer;
begin
  {start off with the correct mask}
  ByteNum := 0;
  BitNum := 7;
  {for all bits...}
  for i := 0 to pred(aHCode.hcBitCount) do begin
    {write the current bit}
    aStream.WriteBit((aHCode.hcCode[ByteNum] and Bit[BitNum]) <> 0);
    {get next bit}
    if (BitNum = 0) then begin
      BitNum := 7;
      inc(ByteNum);
    end
    else
      dec(BitNum);
  end;
end;
{--------}
function ReadChar(aStream : TStream) : char;
{-read a character from the stream}
var
  BytesRead : integer;
begin
  BytesRead := aStream.Read(Result, sizeof(char));
  if (BytesRead <> sizeof(char)) then
    RaiseReadError;
end;
{--------}
function ReadValue(aStream : TStream) : longint;
{-read an integer value from the stream}
var
  BytesRead : integer;
  ValueType : byte;
begin
  Result := 0;
  BytesRead := aStream.Read(ValueType, sizeof(ValueType));
  if (BytesRead <> sizeof(ValueType)) then
    RaiseReadError;
  case ValueType of
    vaByte :
      begin
        BytesRead := aStream.Read(Result, sizeof(byte));
        if (BytesRead <> sizeof(byte)) then
          RaiseReadError;
      end;
    vaWord :
      begin
        BytesRead := aStream.Read(Result, sizeof(word));
        if (BytesRead <> sizeof(word)) then
          RaiseReadError;
      end;
    vaLongint :
      begin
        BytesRead := aStream.Read(Result, sizeof(longint));
        if (BytesRead <> sizeof(longint)) then
          RaiseReadError;
      end;
  else {it's an unknown value type}
    RaiseReadCorruptError;
  end;{case}
end;
{--------}
procedure WriteChar(aStream : TStream; aChar : char);
{-write a character to the stream}
var
  BytesWrit : integer;
begin
  BytesWrit := aStream.Write(aChar, sizeof(char));
  if (BytesWrit <> sizeof(char)) then
    RaiseWriteError;
end;
{--------}
procedure WriteValue(aStream : TStream; aValue : longint);
{-write an integer value to the stream}
var
  BytesWrit : integer;
  ValueType : byte;
begin
  {if the value is between 0 and 255 write a byte to the stream}
  if (0 <= aValue) and (aValue < 256) then begin
    ValueType := vaByte;
    BytesWrit := aStream.Write(ValueType, sizeof(ValueType));
    if (BytesWrit <> sizeof(ValueType)) then
      RaiseWriteError;
    BytesWrit := aStream.Write(aValue, sizeof(byte));
    if (BytesWrit <> sizeof(byte)) then
      RaiseWriteError;
  end
  {if the value is between 256 and 65535 write a word to the stream}
  else if (256 <= aValue) and (aValue < 64*1024) then begin
    ValueType := vaWord;
    BytesWrit := aStream.Write(ValueType, sizeof(ValueType));
    if (BytesWrit <> sizeof(ValueType)) then
      RaiseWriteError;
    BytesWrit := aStream.Write(aValue, sizeof(word));
    if (BytesWrit <> sizeof(word)) then
      RaiseWriteError;
  end
  {otherwise write a longint to the stream}
  else begin
    ValueType := vaLongint;
    BytesWrit := aStream.Write(ValueType, sizeof(ValueType));
    if (BytesWrit <> sizeof(ValueType)) then
      RaiseWriteError;
    BytesWrit := aStream.Write(aValue, sizeof(longint));
    if (BytesWrit <> sizeof(longint)) then
      RaiseWriteError;
  end;
end;
{--------}
procedure CalcCharDistribution(aStream : TStream;
                               aHTree  : PHuffmanTree);
{-calculate the character distribution from the data in the stream;
  fill the first 256 entries in the Huffman tree with the information}
var
  i         : integer;
  Buffer    : PByteArray;
  BytesRead : integer;
begin
  aStream.Position := 0;
  GetMem(Buffer, 1024);
  try
    BytesRead := aStream.Read(Buffer^, 1024);
    while (BytesRead <> 0) do begin
      for i := pred(BytesRead) downto 0 do
        inc(aHTree^[Buffer^[i]].hnCount);
      BytesRead := aStream.Read(Buffer^, 1024);
    end;
  finally
    FreeMem(Buffer, 1024);
  end;
end;
{--------}
procedure ConvertCodeStr(const aHCode  : THuffmanCodeStr;
                               aHCodes : PHuffmanCodes;
                               aNodeInx: integer);
{-convert a code string into binary; store in codes array}
var
  TempCode : THuffmanCode;
  ByteNum  : integer;
  BitNum   : byte;
  i        : integer;
begin
  {set the binary code to zeros, so we only have to record '1' bits}
  FillChar(TempCode, sizeof(TempCode), 0);
  {store the code length}
  TempCode.hcBitCount := length(aHCode);
  {fill the bits from the left in the binary code}
  ByteNum := 0;
  BitNum := 7;
  for i := 1 to length(aHCode) do begin
    if (aHCode[i] = '1') then
      TempCode.hcCode[ByteNum] :=
         TempCode.hcCode[ByteNum] or Bit[BitNum];
    if (BitNum = 0) then begin
      BitNum := 7;
      inc(ByteNum);
    end
    else
      dec(BitNum);
  end;
  {store binary code in the codes array}
  aHCodes^[aNodeInx] := TempCode;
end;
{--------}
procedure CalcHuffmanCodePrim(aNodeInx : integer;
                          var aHCode   : THuffmanCodeStr;
                              aHTree   : PHuffmanTree;
                              aHCodes  : PHuffmanCodes);
{-recursive routine to calculate all the Huffman codes for a given
  Huffman tree}
begin
  {if the current node is not a leaf, then visit the left subtree
   followed by the right subtree}
  if (aNodeInx >= 256) then begin
    {add a 0 bit on the end of the code string}
    inc(aHCode[0]);
    aHCode[length(aHCode)] := '0';
    {visit the left subtree}
    CalcHuffmanCodePrim(aHTree^[aNodeInx].hnLeftInx, aHCode, aHTree, aHCodes);
    {add a 1 bit on the end of the code string}
    aHCode[length(aHCode)] := '1';
    {visit the right subtree}
    CalcHuffmanCodePrim(aHTree^[aNodeInx].hnRightInx, aHCode, aHTree, aHCodes);
    dec(aHCode[0]);
  end
  {if the current node is a leaf, record the current code in the codes
   array}
  else begin
    ConvertCodeStr(aHCode, aHCodes, aNodeInx);
  end;
end;
{--------}
procedure CalcHuffmanCodes(aHTree  : PHuffmanTree;
                           aRoot   : integer;
                           aHCodes : PHuffmanCodes);
{-calculate the Huffman codes for a Huffman tree}
var
  HCode : THuffmanCodeStr;
begin
  {clear the codes array}
  FillChar(aHCodes^, sizeof(aHCodes^), 0);
  {to calculate the codes we have to visit every leaf and for each
   leaf we'll have accumulated a series of bits (going left from a
   parent node to a child node is a 0 bit, going right is a 1 bit);
   for the walk through the tree we'll use a modified inorder
   traversal (ie, visit the left subtree, there's no need to visit the
   node itself, visit the right subtree); because we know the tree has
   a maximum depth of 255, we'll use recursion without getting too
   worried about blowing the stack}
  HCode := '';
  CalcHuffmanCodePrim(aRoot, HCode, aHTree, aHCodes);
end;
{--------}
function ReadNode(aStream : TInputBitStream;
                  aHTree  : PHuffmanTree;
              var aMaxInx : integer) : integer;
var
  IsLeaf  : boolean;
begin
  {read the next bit to determine which node we have to create}
  IsLeaf := aStream.ReadBit;
  {if it's a leaf then return its node index (ie, the character)}
  if IsLeaf then
    Result := aStream.ReadByte
  {if it's an internal node, get the left and right subtrees}
  else begin
    inc(aMaxInx);
    Result := aMaxInx;
    aHTree^[Result].hnLeftInx := ReadNode(aStream, aHTree, aMaxInx);
    aHTree^[Result].hnRightInx := ReadNode(aStream, aHTree, aMaxInx);
  end;
end;
{--------}
function ReadCharDistribution(aStream : TInputBitStream;
                              aHTree  : PHuffmanTree) : integer;
{-read a character distribution from a stream}
var
  MaxInx : integer;
begin
  MaxInx := 255;
  Result := ReadNode(aStream, aHTree, MaxInx);
end;
{--------}
procedure WriteNode(aStream  : TOutputBitStream;
                    aHTree   : PHuffmanTree;
                    aNodeInx : integer);
begin
  {for a leaf, write a 1 bit, followed by the character}
  if (aNodeInx < 256) then begin
    aStream.WriteBit(true);
    aStream.WriteByte(aNodeInx);
  end
  {for an internal node, write a 0 bit, then the left subtree, then
   the right subtree}
  else begin
    aStream.WriteBit(false);
    WriteNode(aStream, aHTree, aHTree^[aNodeInx].hnLeftInx);
    WriteNode(aStream, aHTree, aHTree^[aNodeInx].hnRightInx);
  end;
end;
{--------}
procedure WriteCharDistribution(aStream : TOutputBitStream;
                                aHTree  : PHuffmanTree;
                                aRootInx: integer);
{-write a character distribution to a stream}
begin
  WriteNode(aStream, aHTree, aRootInx);
end;
{--------}
procedure BuildHuffmanTree(aHTree         : PHuffmanTree;
                       var aLastParentInx : integer);
{-given a Huffman tree just containing the character distributions,
  build the entire tree; return the index of the root}
var
  i  : integer;
  PQ : THuffmanPriorityQueue;
  Node1Inx  : longint;
  Node2Inx  : longint;
  ParentInx : integer;
begin
  ParentInx := aLastParentInx;
  {create a priority queue}
  PQ := THuffmanPriorityQueue.Create(aHTree);
  try
    {add all the non-zero nodes to the queue}
    for i := 0 to 255 do
      if (aHTree^[i].hnCount <> 0) then
        PQ.Add(i);
    {SPECIAL CASE: there is only one non-zero node, ie the input
     stream consisted of just one character, repeated one or more
     times; set the parent index to the single character}
    if (PQ.Count = 1) then
      ParentInx := PQ.Remove
    {otherwise we have the normal, many different chars, case}
    else
      {while there is more than one item in the queue, remove the two
       smallest, join them to a new parent, and add the parent to the
       queue}
      while (PQ.Count > 1) do begin
        Node1Inx := PQ.Remove;
        Node2Inx := PQ.Remove;
        inc(ParentInx);
        with aHTree^[ParentInx] do begin
          hnLeftInx := Node1Inx;
          hnRightInx := Node2Inx;
          hnCount := aHTree^[Node1Inx].hnCount +
                     aHTree^[Node2Inx].hnCount;
        end;
        PQ.Add(ParentInx);
      end;
  finally
    PQ.Free;
  end;
  aLastParentInx := ParentInx;
end;
{--------}
procedure DoHuffmanCompression(aInStream  : TStream;
                               aOutStream : TOutputBitStream;
                               aHCodes    : PHuffmanCodes);
{-given an array of Huffman codes, compress the input stream to the
  output stream}
var
  B : byte;
  i : integer;
begin
  {reset the input stream to the start}
  aInStream.Position := 0;
  {for each character in the input stream, write its Huffman code to
   the output stream}
  for i := 0 to pred(aInStream.Size) do begin
    aInStream.Read(B, sizeof(B));
    WriteBits(aHCodes^[B], aOutStream);
  end;
end;
{--------}
procedure DoHuffmanDecompression(aInStream  : TInputBitStream;
                                 aOutStream : TStream;
                                 aHTree     : PHuffmanTree;
                                 aRoot      : integer);
{-given a Huffman tree, decompress the input stream to the output
  stream}
var
  CharCount      : longint;
  TotalCharCount : longint;
  CurrNode       : integer;
  GoLeft         : boolean;
  Ch             : char;
begin
  {calculate the total number of characters to decompress; preset the
   loop variables}
  TotalCharCount := aHTree^[aRoot].hnCount;
  CharCount := 0;
  CurrNode := aRoot;
  {repeat until all the characters have been decompressed}
  while CharCount < TotalCharCount do begin
    {read the next bit}
    GoLeft := not aInStream.ReadBit;
    {walk down the Huffman tree}
    if GoLeft then
      CurrNode := aHTree^[CurrNode].hnLeftInx
    else
      CurrNode := aHTree^[CurrNode].hnRightInx;
    {if we have reached a leaf, output the character concerned, and
     reset the current node to the root}
    if (CurrNode < 256) then begin
      Ch := char(CurrNode);
      aOutStream.Write(Ch, sizeof(byte));
      CurrNode := aRoot;
      inc(CharCount);
    end;
  end;
end;
{--------}
procedure WriteMultipleChars(aStream : TStream;
                             aCh     : char;
                             aCount  : longint);
{-write several copies of a character to a stream}
const
  BufferSize = 1024;
var
  Buffer       : PByteArray;
  BytesToWrite : integer;
  BytesWrit    : integer;
begin
  GetMem(Buffer, BufferSize);
  try
    FillChar(Buffer^, BufferSize, aCh);
    while (aCount > 0) do begin
      if (aCount < BufferSize) then
        BytesToWrite := aCount
      else
        BytesToWrite := BufferSize;
      BytesWrit := aStream.Write(Buffer^, BytesToWrite);
      dec(aCount, BytesWrit);
    end;
  finally
    FreeMem(Buffer, BufferSize);
  end;
end;
{====================================================================}


{===Interfaced routines==============================================}
procedure HuffmanCompress(aInStream, aOutStream : TStream);
var
  HTree  : PHuffmanTree;
  Root   : integer;
  HCodes : PHuffmanCodes;
  Size   : longint;
  OutputBitStream : TOutputBitStream;
begin
  {write the number of characters in the input stream to the output
   stream; this aids in decompression--we know when to stop}
  Size := aInStream.Size;
  aOutStream.Write(Size, sizeof(Size));
  {if there's nothing to compress, exit now}
  if (Size = 0) then
    Exit;
  {prepare}
  HTree := nil;
  OutputBitStream := nil;
  try
    {allocate the Huffman tree}
    New(HTree);
    {initialise the tree}
    FillChar(HTree^, sizeof(HTree^), 0);
    {get the distribution of characters in the input stream, place in
     the first 256 elements of the Huffman tree}
    CalcCharDistribution(aInStream, HTree);
    {build the Huffman tree}
    Root := 255;
    BuildHuffmanTree(HTree, Root);
    {create the output bit stream}
    OutputBitStream := TOutputBitStream.Create(aOutStream);
    {when this point is reached we know the Huffman tree is rooted at
     Root; if Root is a leaf, then the input stream just consisted of
     repetitions of one character, so output the minimal compressed
     data, essentially RLE compression}
    if (Root < 256) then
      WriteCharDistribution(OutputBitStream, HTree, Root)
    else {Root is not a leaf} begin
      {allocate the codes array}
      New(HCodes);
      try
        {calculate all the codes}
        CalcHuffmanCodes(HTree, Root, HCodes);
        {we are now ready to compress the input stream, however we
         must first output the tree to the output stream to aid the
         decompressor}
        WriteCharDistribution(OutputBitStream, HTree, Root);
        {compress the characters in the input stream}
        DoHuffmanCompression(aInStream, OutputBitStream, HCodes);
      finally
        Dispose(HCodes);
      end;
    end;
  finally
    if (HTree <> nil) then
      Dispose(HTree);
    OutputBitStream.Free;
  end;
end;
{--------}
procedure HuffmanDecompress(aInStream, aOutStream : TStream);
var
  HTree : PHuffmanTree;
  Root  : integer;
  Size  : longint;
  InputBitStream : TInputBitStream;
begin
  {if there's nothing to decompress, exit now}
  if (aInStream.Size = 0) then
    Exit;
  aInStream.ReadBuffer(Size, sizeof(Size));
  if (Size = 0) then
    Exit;
  {prepare}
  HTree := nil;
  InputBitStream := nil;
  try
    {allocate the Huffman tree}
    New(HTree);
    {initialise the tree}
    FillChar(HTree^, sizeof(HTree^), 0);
    {create the input bit stream}
    InputBitStream := TInputBitStream.Create(aInStream);
    {read the Huffman tree from the input stream}
    Root := ReadCharDistribution(InputBitStream, HTree);
    {when this point is reached we know the Huffman tree is rooted at
     Root; if Root is a leaf, then the original stream just consisted
     of repetitions of one character}
    if (Root < 256) then
      WriteMultipleChars(aOutStream, char(Root), HTree^[Root].hnCount)
    {otherwise, using the Huffman tree, decompress the characters in
     the input stream; note that the number of chars to decompress
     is the count at the root of the Huffman tree}
    else begin
      HTree^[Root].hnCount := Size;
      DoHuffmanDecompression(InputBitStream, aOutStream, HTree, Root);
    end;
  finally
    if (HTree <> nil) then
      Dispose(HTree);
    InputBitStream.Free;
  end;
end;
{====================================================================}


{====================================================================}
type
  TBlockStream = class(TCustomMemoryStream)
    private
      FPosition : integer;
    public
      constructor Create(var aBuffer; aSize : integer);
      function Write(const aBuffer; aCount: longint) : longint; override;
  end;
{--------}
constructor TBlockStream.Create(var aBuffer; aSize : integer);
begin
  inherited Create;
  SetPointer(@aBuffer, aSize);
end;
{--------}
function TBlockStream.Write(const aBuffer; aCount: longint) : longint;
begin
  Move(aBuffer, (PChar(Memory) + FPosition)^, aCount);
  inc(FPosition, aCount);
  Result := aCount;
end;
{====================================================================}
procedure HuffmanCompressBlock(var aBuffer;
                                   aSize      : integer;
                                   aOutStream : TStream);
var
  MemStrm : TBlockStream;
begin
  MemStrm := TBlockStream.Create(aBuffer, aSize);
  try
    HuffmanCompress(MemStrm, aOutStream);
  finally
    MemStrm.Free;
  end;
end;
{--------}
procedure HuffmanDecompressBlock(aInStream : TStream;
                             var aBuffer;
                                 aSize     : integer);
var
  MemStrm : TBlockStream;
begin
  MemStrm := TBlockStream.Create(aBuffer, aSize);
  try
    HuffmanDecompress(aInStream, MemStrm);
  finally
    MemStrm.Free;
  end;
end;
{====================================================================}


end.